home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
CICA 1993 April
/
CICA MS Windows - April 1993.iso
/
unzipped
/
programr
/
tp
/
modem
/
modemfax.pas
< prev
Wrap
Pascal/Delphi Source File
|
1991-08-22
|
10KB
|
338 lines
uses WinTypes, WinProcs, WObjects, Strings;
const
idEdit = 100;
LineWidth = 80; { Width of each line displayed. }
LineHeight = 60; { Number of line that are held in memory. }
{ The configuration string bellow is used to configure the modem. }
{ It is set for communication port 2, 2400 baud, No parity, 8 data }
{ bits, 1 stop bit. }
Config = 'com2:24,n,8,1';
{ An example of using communication port 1, 1200 baud, Even parity }
{ 7 data bits, 2 stop bits. }
{ Config = 'com1:12,e,7,2'; }
type
TApp = object(TApplication)
procedure Idle; virtual;
procedure InitMainWindow; virtual;
procedure MessageLoop; virtual;
end;
PBuffer = ^TBuffer;
TBuffer = object(TCollection)
Pos: Integer;
constructor Init(AParent: PWindow);
procedure FreeItem(Item: Pointer); virtual;
function PutChar(C: Char): Boolean;
end;
PCommWindow = ^TCommWindow;
TCommWindow = object(TWindow)
Cid: Integer;
Buffer: PBuffer;
FontRec: TLogFont;
CharHeight: Integer;
constructor Init(AParent: PWindowsObject; ATitle: PChar);
destructor Done; virtual;
procedure Error(E: Integer; C: PChar);
procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
procedure ReadChar; virtual;
procedure SetHeight;
procedure SetUpWindow; virtual;
procedure wmChar(var Message: TMessage);
virtual wm_Char;
procedure wmSize(var Message: TMessage);
virtual wm_Size;
procedure WriteChar;
end;
{ TBuffer }
{ The Buffer is use to hold each line that is displayed in the main }
{ window. The constance LineHeight determines the number of line that }
{ are stored. The Buffer is prefilled with the LineHeight worth of }
{ lines. }
constructor TBuffer.Init(AParent: PWindow);
var
P: PChar;
I: Integer;
begin
TCollection.Init(LineHeight + 1, 10);
GetMem(P, LineWidth + 1);
P[0] := #0;
Pos := 0;
Insert(P);
for I := 1 to LineHeight do
begin
GetMem(P, LineWidth + 1);
P[0] := #0;
Insert(P);
end;
end;
procedure TBuffer.FreeItem(Item: Pointer);
begin
FreeMem(Item, LineWidth + 1);
end;
{ This procedure is process all incomming in formation from the com }
{ port. This procedure is called by TCommWindow.ReadChar. }
function TBuffer.PutChar(C: Char): Boolean;
var
Width: Integer;
P: PChar;
begin
PutChar := False;
Case C of
#13: Pos := 0; { if a Carriage Return. }
#10: { if a Line Feed. }
begin
GetMem(P, LineWidth + 1);
FillChar(P^, LineWidth + 1, ' ');
P[Pos] := #0;
Insert(P);
end;
#8:
if Pos > 0 then { if a Delete. }
begin
Dec(Pos);
P := At(Count - 1);
P[Pos] := ' ';
end;
#32..#128: { else handle all other }
begin { displayable characters.}
P := At(Count - 1);
Width := StrLen(P);
if Width > LineWidth then { if line is to wide }
begin { create a new line. }
Pos := 1;
GetMem(P, LineWidth + 1);
P[0] := C;
P[1] := #0;
Insert(P);
end
else { else add character }
begin { to current line. }
P[Pos] := C;
Inc(Pos);
P[Pos] := #0;
end;
end;
end;
if Count > LineHeight then { if more to many lines }
begin { have been added delete}
AtFree(0); { current line and let }
PutChar := True; { the call procedure }
end; { know to scroll up. }
end;
{ TCommWindow }
{ The CommWindow displays the incoming and out goinging text. There }
{ should be mention that the text type by the use is displayed by }
{ being echo back to the ReadChar procedure. So there is no need for }
{ wmChar to write a character to the screen. }
constructor TCommWindow.Init(AParent: PWindowsObject; ATitle: PChar);
begin
TWindow.Init(AParent, ATitle);
Attr.Style := Attr.Style or ws_VScroll;
Scroller := New(PScroller, Init(@Self, 1, 1, 100, 100));
Buffer := New(PBuffer, Init(@Self));
end;
{ Close the Comm port and deallocate the Buffer. }
destructor TCommWindow.Done;
begin
Error(CloseComm(Cid), 'Close');
Dispose(Buffer, Done);
TWindow.Done;
end;
{ Checks for comm errors and writes any errors. }
procedure TCommWindow.Error(E: Integer; C: PChar);
var
S: array[0..100] of Char;
begin
if E >= 0 then exit;
Str(E, S);
MessageBox(GetFocus, S, C, mb_Ok);
end;
{ Redraw all the lines in the buffer by using ForEach. }
procedure TCommWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
var
I: Integer;
Font: HFont;
procedure WriteOut(Item: PChar); far;
begin
TextOut(PaintDC, 0, CharHeight * I, Item, StrLen(Item));
inc(I);
end;
begin
I := 0;
Font := SelectObject(PaintDC, CreateFontIndirect(FontRec));
Buffer^.ForEach(@WriteOut);
DeleteObject(SelectObject(PaintDC, Font));
end;
{ Read a charecter from the comm port, if there is no error then call }
{ Buffer^.PutChar to add it to the buffer and write it to the screen. }
procedure TCommWindow.ReadChar;
var
Stat: TComStat;
I, Size: Integer;
C: Char;
begin
GetCommError(CID, Stat);
for I := 1 to Stat.cbInQue do
begin
Size := ReadComm(CId, @C, 1);
Error(Size, 'Read Comm');
if C <> #0 then
begin
if Buffer^.PutChar(C) then
begin
ScrollWindow(HWindow, 0, -CharHeight, Nil, Nil);
UpDateWindow(HWindow);
end;
WriteChar;
end;
end;
end;
procedure TCommWindow.SetUpWindow;
var
DCB: TDCB;
begin
TWindow.SetUpWindow;
SetHeight;
{ Open for Comm2 2400 Baud, No Parity, 8 Data Bits, 1 Stop Bit }
BuildCommDCB(Config, DCB);
Cid := OpenComm('COM2', 1024, 1024);
Error(Cid, 'Open');
DCB.ID := CID;
Error(SetCommState(DCB), 'Set Comm State');
WriteComm(Cid, 'ATZ'#13#10, 5); { Send a reset to Modem. }
end;
{ Call back function used only in to get record structure for fixed }
{ width font. }
function GetFont(LogFont: PLogFont; TM: PTextMetric; FontType: Word;
P: PCommWindow): Integer; export;
begin
if P^.CharHeight = 0 then
begin
P^.FontRec := LogFont^;
P^.CharHeight := P^.FontRec.lfHeight;
end;
end;
{ Get the a fix width font to use in the TCommWindow. Use EnumFonts }
{ to save work of create the FontRec by hand. }
{ The TScroller of the main window is also updated know that the font }
{ height is known. }
procedure TCommWindow.SetHeight;
var
DC: HDC;
ProcInst: Pointer;
begin
DC := GetDC(HWindow);
CharHeight := 0;
ProcInst := MakeProcInstance(@GetFont, HInstance);
EnumFonts(DC, 'Courier', ProcInst, @Self);
FreeProcInstance(ProcInst);
ReleaseDC(HWindow, DC);
Scroller^.SetUnits(CharHeight, CharHeight);
Scroller^.SetRange(LineWidth, LineHeight);
Scroller^.ScrollTo(0, LineHeight);
end;
{ Write the character from the pressed key to the Comuniction Port. }
procedure TCommWindow.wmChar(var Message: TMessage);
begin
if CID <> 0 then
Error(WriteComm(CId, @Message.wParam, 1), 'Writing');
end;
procedure TCommWindow.wmSize(var Message: TMessage);
begin
TWindow.wmSize(Message);
Scroller^.SetRange(LineWidth, LineHeight - (Message.lParamhi div CharHeight));
end;
procedure TCommWindow.WriteChar;
var
DC: HDC;
Font: HFont;
S: PChar;
APos: Integer;
begin
APos := Buffer^.Count - 1;
S := Buffer^.AT(APos);
APos := (APos - Scroller^.YPos) * CharHeight;
if APos < 0 then exit;
if Hwindow <> 0 then
begin
DC := GetDC(HWindow);
Font := SelectObject(DC, CreateFontIndirect(FontRec));
TextOut(DC, 0, APos, S, StrLen(S));
DeleteObject(SelectObject(DC, Font));
ReleaseDC(HWindow, DC);
end;
end;
{ TApp }
procedure TApp.Idle;
var
Stat: TComStat;
I, Size: Integer;
C: Char;
begin
if MainWindow <> Nil then
if MainWindow^.HWindow <> 0 then
PCommWindow(MainWindow)^.ReadChar;
end;
procedure TApp.InitMainWindow;
begin
MainWindow := New(PCommWindow, Init(Nil, 'Comm Test'));
end;
{ Add Idle loop to main message loop. }
procedure TApp.MessageLoop;
var
Message: TMsg;
begin
while True do
begin
if PeekMessage(Message, 0, 0, 0, pm_Remove) then
begin
if Message.Message = wm_Quit then Exit;
if not ProcessAppMsg(Message) then
begin
TranslateMessage(Message);
DispatchMessage(Message);
end;
end
else
Idle;
end;
Status := Message.WParam;
end;
var
App: TApp;
begin
App.Init('Comm');
App.Run;
App.Done;
end.